home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / archiver / ldiff12s.zip / MYTOOL.PAS < prev    next >
Pascal/Delphi Source File  |  1989-07-15  |  13KB  |  567 lines
  1. (*---------------------------------------------------------------------------*)
  2. (*mytool.pas ö─ùpè╓Éö               (C) ÄOû╪ÿaòF NIFTY SDR SDI00147 1989/2/12*)
  3. (*$B-,F-,I-,N-                                                               *)
  4. (*---------------------------------------------------------------------------*)
  5. UNIT MyTool;
  6.  
  7.  
  8. INTERFACE
  9.  
  10.  
  11. USES
  12.    Dos,
  13.    KErr,
  14.    MyType;
  15.  
  16.  
  17. CONST
  18.    KanjiCharSet  : CSet   = [#$81..#$9F,#$E0..#$FC];
  19.    ErrStr        : STRING = '';
  20. VAR
  21.    Regs          : Registers;
  22.    ERRF,OUTF,INF : Text;
  23.    SwitchChar    : Char;
  24.    PathDelim     : Char;
  25.  
  26.  
  27. FUNCTION  AscZ         (VAR _h):STRING;
  28. FUNCTION  Byte16Chr    (i:BYTE):CHAR;
  29. FUNCTION  Byte16Str    (i:WORD):Str2;
  30. FUNCTION  Byte10Str    (i:BYTE):Str2;
  31. FUNCTION  ChkDir       (path:PathStr):BOOLEAN;
  32. FUNCTION  ChkWild      (path:PathStr):CHAR;
  33. FUNCTION  ClrL         (len:BYTE;c:CHAR):STRING;
  34. FUNCTION  CmpExt       (s:STRING):BOOLEAN;
  35. FUNCTION  CmpStr       (s1,s2:STRING):INTEGER;
  36. FUNCTION  CmpWithWild  (s1,s2:STRING):BOOLEAN;
  37. FUNCTION  DateTimeStr  (time:LONGINT):Str18;
  38. FUNCTION  DelSpace     (s:STRING):STRING;
  39. FUNCTION  DosFree      :LONGINT;
  40. FUNCTION  FExist       (path:PathStr):WORD;
  41. FUNCTION  FileAtrStr   (VAR attr:BYTE):Str6;
  42. FUNCTION  Fill         (n:BYTE;c:CHAR):STRING;
  43. PROCEDURE FSplit       (path:PathStr;VAR d:DirStr;VAR n:NameStr;VAR e:ExtStr);
  44. FUNCTION  FTime        (path:PathStr):LONGINT;
  45. FUNCTION  GetChar      :CHAR;
  46. FUNCTION  GetDirName   (VAR s:DirStr):Str13;
  47. FUNCTION  GetEnviro    (s:STRING):STRING;
  48. FUNCTION  GetStr       (VAR s:STRING):STRING;
  49. FUNCTION  Long16Str    (n:longint):Str8;
  50. FUNCTION  Long2Char    (l:LONGINT):Str4;
  51. FUNCTION  LengZ        (VAR _h):WORD;
  52. FUNCTION  MaxLong      (x,y:LONGINT):LONGINT;
  53. FUNCTION  MinLong      (x,y:LONGINT):LONGINT;
  54. FUNCTION  NewFname     (old:PathStr;ext:ExtStr;mode:CHAR):PathStr;
  55. FUNCTION  NoCheckCTRL  (fh:WORD):BYTE;
  56. FUNCTION  ChangeDirName(d:DirStr):DirStr;
  57. FUNCTION  ReMove       (fn:PathStr):BOOLEAN;
  58. FUNCTION  ResetFn      (fn:PathStr):Str12;
  59. FUNCTION  ResetPath    (path:PathStr):PathStr;
  60. PROCEDURE SetIOCTRL    (fh:WORD;code:BYTE);
  61. FUNCTION  UpCaseStr    (s:STRING):STRING;
  62. FUNCTION  Word16Str    (i:WORD):Str4;
  63.  
  64.  
  65. IMPLEMENTATION
  66.  
  67.  
  68. VAR
  69.    ExitSave : POINTER;
  70.  
  71. CONST
  72.    CHR16    : ARRAY[0..15] OF CHAR='0123456789ABCDEF';
  73.  
  74.  
  75. FUNCTION MinLong(x,y:LONGINT):LONGINT;
  76. BEGIN
  77.    IF x<y THEN MinLong:=x ELSE MinLong:=y;
  78. END;
  79.  
  80.  
  81. FUNCTION MaxLong(x,y:LONGINT):LONGINT;
  82. BEGIN
  83.    IF x>y THEN MaxLong:=x ELSE MaxLong:=y;
  84. END;
  85.  
  86.  
  87. FUNCTION NewFname(old:PathStr;ext:ExtStr;mode:CHAR):PathStr;
  88. VAR
  89.    d : DirStr;
  90.    n : NameStr;
  91.    e : ExtStr;
  92. BEGIN
  93.    FSplit(old,d,n,e);
  94.    IF e='' THEN
  95.       NewFname:=old+'.'+ext
  96.    ELSE
  97.       CASE mode OF
  98.          '+' : NewFname:=old;
  99.          '-' : NewFname:=d+n+'.'+ext;
  100.       END;
  101. END;
  102.  
  103.  
  104. PROCEDURE FSplit(path:PathStr;VAR d:DirStr;VAR n:NameStr;VAR e:ExtStr);
  105. VAR
  106.    l,p,np,ep : BYTE;
  107. BEGIN
  108.    d:='';
  109.    n:='';
  110.    e:='';
  111.    path:=path+NUL;
  112.    l:=Length(path);
  113.    ep:=l;
  114.    np:=1;
  115.    p :=1;
  116.    WHILE path[p]<>NUL DO BEGIN
  117.       IF path[p] IN [':','\',PathDelim] THEN np:=SUCC(p);
  118.       IF path[p]='.'                    THEN ep:=p;
  119.       IF path[p] IN KanjiCharSet THEN Inc(p,2) ELSE Inc(p);END;
  120.    IF (Copy(path,np,l-np)='.') OR (copy(path,np,l-np)='..') THEN BEGIN
  121.       e:='';
  122.       d:=copy(path,1,PRED(np));
  123.       n:=copy(path,np,l-np);END
  124.    ELSE BEGIN
  125.       IF ep<np THEN ep:=l;
  126.       d:=copy(path, 1,PRED(np));
  127.       n:=copy(path,np,ep-np   );
  128.       e:=copy(path,ep,l-ep    );
  129.    END;
  130. END;
  131.  
  132.  
  133. FUNCTION DosFree:LONGINT;
  134. VAR
  135.    env,n,m : WORD;
  136. BEGIN
  137.    env:=Pred(MemW[PrefixSeg:$2C]);
  138.    n:=MemW[env:3];
  139.    DosFree:=LONGINT(16)*(n+MemW[Succ(env+n):3]);
  140. END;
  141.  
  142.  
  143. FUNCTION GetEnviro(s:STRING):STRING;
  144. VAR
  145.    i,EnviroSeg : WORD;
  146.    SS          : STRING;
  147. BEGIN
  148.    EnviroSeg:=memw[PrefixSeg:$002c];
  149.    i:=0;
  150.    REPEAT
  151.       ss:=AscZ(mem[EnviroSeg:i]);
  152.       IF ss='' THEN BEGIN GetEnviro:='';Exit;END
  153.       ELSE IF Copy(ss,1,Succ(length(s)))=(s+'=') THEN BEGIN
  154.          GetEnviro:=copy(ss,length(s)+2,255);Exit;END
  155.       ELSE
  156.          Inc(i,LengZ(mem[EnviroSeg:i]));
  157.   UNTIL FALSE;
  158. END;
  159.  
  160.  
  161. FUNCTION GetStr(VAR s:STRING):STRING;
  162. VAR
  163.    ss : STRING;
  164. BEGIN
  165.    s:=DelSpace(s);
  166.    ss:='';
  167.    WHILE (s<>'') AND (NOT (s[1] IN [SPACE,TAB])) DO BEGIN
  168.        ss:=ss+s[1];Delete(s,1,1);END;
  169.    s:=DelSpace(s);
  170.    GetStr:=ss;
  171. END;
  172.  
  173.  
  174. FUNCTION DelSpace(s:STRING):STRING;
  175. VAR
  176.    n  : INTEGER;
  177.   _s : ARRAY[0..256] OF BYTE ABSOLUTE s;
  178. BEGIN
  179.    n:=1;
  180.    WHILE (n<=_s[0]) and (S[n] in [SPACE,TAB]) DO INC(n);
  181.    delete(s,1,PRED(n));
  182.    n:=length(s);
  183.    WHILE (n>0) and (s[n] IN [SPACE,TAB]) DO DEC(n);
  184.    _s[0]:=n;
  185.    DelSpace:=s;
  186. END;
  187.  
  188.  
  189. PROCEDURE SetIOCTRL(fh:WORD;code:BYTE);
  190. BEGIN
  191.    WITH Regs DO BEGIN
  192.       BX:=fh;
  193.       AX:=$4401;
  194.       DX:=code;
  195.       MsDos(Regs);
  196.    END;
  197. END;
  198.  
  199.  
  200. FUNCTION NoCheckCTRL(fh:WORD):BYTE;
  201. BEGIN
  202.    WITH Regs DO BEGIN
  203.       AX:=$4400;
  204.       BX:=fh;
  205.       MsDos(Regs);
  206.       NoCheckCTRL:=DL;
  207.       AX:=$4401;
  208.       DX:=(DL OR $20);
  209.       MsDos(Regs);
  210.    END;
  211. END;
  212.  
  213.  
  214. FUNCTION GetChar:CHAR;
  215. VAR
  216.    IOflg : BYTE;
  217.    c     : CHAR;
  218.    fh1   : WORD;
  219. BEGIN
  220.    WITH Regs DO BEGIN
  221.       IOflg:=NoCheckCTRL(2);
  222.       AH:=$45;  BX:=1;                                  MsDos(Regs); FH1:=AX;
  223.       AH:=$46;  BX:=2;   CX:=1;                         MsDos(Regs);
  224.       AH:=$3F;  BX:=2;   CX:=1; DS:=Seg(c); DX:=Ofs(c); MsDos(Regs);
  225.       AH:=$46;  BX:=FH1; CX:=1;                         MsDos(Regs);
  226.       AH:=$3E;  BX:=FH1;                                MsDos(Regs);
  227.       SetIOCTRL(2,IOflg);END;
  228.    GetChar:=c;
  229. END;
  230.  
  231.  
  232. FUNCTION ClrL(len:BYTE;c:CHAR):STRING;
  233. BEGIN
  234.    ClrL:=Fill(len,c)+Fill(len,BS);
  235. END;
  236.  
  237.  
  238. FUNCTION ChkDir(path:PathStr):BOOLEAN;
  239. VAR
  240.    d   : DirStr;
  241.    n   : NameStr;
  242.    e   : ExtStr;
  243.    dta : SearchRec;
  244. BEGIN
  245.    IF ChkWild(path)=NUL THEN
  246.      IF ((Length(path)=2) AND (path[2]=':')) OR
  247.        ((Length(path)<>0) AND (path[Length(path)] IN [PathDelim,'\']))
  248.       THEN ChkDir:=TRUE
  249.       ELSE BEGIN
  250.          path:=UpCaseStr(path);
  251.          FSplit(path,d,n,e);
  252.          FindFirst(d+'*.*',AnyFile,dta);
  253.          WHILE DosError=0 DO WITH dta DO BEGIN
  254.             IF (n+e=name) AND ((attr AND Directory)<>0) THEN BEGIN
  255.                ChkDir:=TRUE;Exit;END;
  256.             FindNext(dta);END;
  257.          ChkDir:=FALSE;END
  258.    ELSE
  259.       ChkDir:=FALSE;
  260. END;
  261.  
  262.  
  263. FUNCTION FileAtrStr(VAR attr:BYTE):Str6;
  264. BEGIN
  265.    FileAtrStr:=copy('-w',succ(Attr AND readonly),1)+
  266.                copy('-h',succ(ord((Attr AND hidden   )= 2)),1)+
  267.                copy('-s',succ(ord((Attr AND sysfile  )= 4)),1)+
  268.                copy('-v',succ(ord((Attr AND volumeid )= 8)),1)+
  269.                copy('-d',succ(ord((Attr AND directory)=16)),1)+
  270.                copy('-a',succ(ord((Attr AND archive  )=32)),1);
  271. END;
  272.  
  273.  
  274. FUNCTION DateTimeStr(time:LONGINT):Str18;
  275. VAR
  276.    years,hours           : Str4;
  277.    months,days,mins,secs : Str2;
  278.    dt                    : datetime;
  279. BEGIN
  280.    WITH dt DO BEGIN
  281.       unpacktime (time,dt);
  282.       Str(year    ,years );
  283.       Str(month:2 ,months);
  284.       Str(day:2   ,days  );
  285.       Str(hour:4  ,hours );
  286.       Str(min:2   ,mins  );
  287.       Str(sec:2   ,secs  );
  288.       IF months[1]=' ' THEN months[1]:='0';
  289.       IF days  [1]=' ' THEN days  [1]:='0';
  290.       IF mins  [1]=' ' THEN mins  [1]:='0';
  291.       IF secs  [1]=' ' THEN secs  [1]:='0';
  292.       DateTimeStr:=copy(years,3,2)+'/'+months+'/'+days+
  293.                    hours          +':'+mins  +':'+secs;
  294.    END;
  295. END;
  296.  
  297.  
  298. FUNCTION CmpWithWild(s1,s2:STRING):BOOLEAN;
  299. VAR
  300.    i : BYTE;
  301.    s : STRING;
  302. BEGIN
  303.    CmpWithWild:=FALSE;
  304.    CASE ChkWild(s1) OF
  305.       NUL : BEGIN CmpWithWild:=(s1=s2);Exit;END;
  306.       '?' : IF length(s1)<>length(s2) THEN Exit ELSE s:=s1;
  307.    ELSE
  308.       IF Pred(Length(s1))>Length(s2) THEN Exit;
  309.       s:=Fill(Length(s2),'?');
  310.       IF s1[Length(s1)]='*' THEN
  311.          FOR i:=1 TO Pred(Length(s1)) DO s[i]:=s1[i]
  312.       ELSE
  313.          FOR i:=Length(s1) DOWNTO 2 DO s[Length(s)-Length(s1)+i]:=s1[i];END;
  314.    FOR i:=1 to Length(s) DO IF (